{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Melody
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Melody - notes and rests (no duration).
--
--------------------------------------------------------------------------------

module Majalan.Base.Melody
  ( 
    Melody
  , melodyFw
  , pitches
  , arpeggioNotes
  , norep
  , deleteRests
  , concat
  , reverse
  , repeatN
  , filter
  , interleave 
  , intersperse
  , intercalate
  , permutations
  , partition
  , duplicate

  , retrograde

  ) where


import qualified Majalan.Base.Arpa as Arpa
import Majalan.Base.Event
import Majalan.Base.EventList
import Majalan.Base.Impulse
import Majalan.Base.Internal.Utils

import qualified Data.List as List
import Data.Monoid

import Prelude hiding ( filter, replicate, reverse, concat )




data Elt pch = R | N pch
  deriving (Eq,Ord,Show)

instance Functor Elt where
  fmap f (N p)  = N $ f p
  fmap _ (R)    = R

-- We are not so worried about the efficiency of transposing 
-- between standard lists and H-Lists...
-- 
newtype Melody pch = Melody { getMelody :: H (Elt pch) }


instance Monoid (Melody pch) where
  mempty            = Melody $ emptyH
  a1 `mappend` a2   = Melody $ getMelody a1 `appendH` getMelody a2

instance Functor Melody where
  fmap f = Melody . fromListH . map (fmap f) . toListH . getMelody

-- | Nothing = rest
evalMelody :: Melody pch -> [Maybe pch]
evalMelody = map fn . toListH . getMelody
   where
     fn (N p) = Just p
     fn R     = Nothing

melodyFw :: Ord pch 
         => Melody pch -> ImpulseMap a 
         -> (pch -> a -> EventFw uctx z)
         -> EventList uctx ()
melodyFw ps imap mf = 
    impulsesFw (xzipImpulseMb (evalMelody ps) imap) $ uncurry mf

--------------------------------------------------------------------------------
-- Primitive builders

pitches :: [pch] -> Melody pch
pitches = Melody . fromListH . map N


arpeggioNotes :: Ord pch => Arpa.Arpeggio pch -> Melody pch
arpeggioNotes = pitches . Arpa.evalArpeggio

--------------------------------------------------------------------------------
-- Introspective

type ListF p1 p2 = [Elt p1] -> [Elt p2]

listfun :: ListF p1 p2 -> Melody p1 -> Melody p2
listfun fn = Melody . fromListH . fn . toListH . getMelody


norep :: Eq pch => Melody pch -> Melody pch
norep = listfun fn
  where
    fn (N x: N y: xs)   | x==y  = fn $ N y:xs
    fn (x:xs)                   = x : fn xs
    fn []                       = []

deleteRests :: Melody pch -> Melody pch
deleteRests = listfun fn
  where
    fn (R:xs)   = xs
    fn (x:xs)   = x : fn xs
    fn []       = []


-- List-like functionals should respect the type signatures of
-- the original list ops, even if that means client code always 
-- has to use concat to linearize them.

concat :: [Melody pch] -> Melody pch
concat = mconcat
 

reverse :: Melody pch -> Melody pch
reverse = listfun List.reverse

repeatN :: Int -> Melody pch -> Melody pch
repeatN i = listfun (List.concat . List.replicate i)


filter :: (pch -> Bool) -> Melody pch -> Melody pch
filter f = listfun (List.filter f2)
  where
    f2 (N p) = f p
    f2 R     = True

interleave :: Melody pch -> Melody pch -> Melody pch
interleave m1 m2 = 
    Melody $ fn (toListH $ getMelody m1) (toListH $ getMelody m2) emptyH
  where
    fn xs     []     ac = ac `appendH` fromListH xs
    fn []     ys     ac = ac `appendH` fromListH ys
    fn (x:xs) (y:ys) ac = fn xs ys (ac `snocH` x `snocH` y)

intersperse :: pch -> Melody pch -> Melody pch
intersperse p = listfun (\xs -> List.intersperse (N p) xs)


intercalate :: Melody pch -> [Melody pch] -> Melody pch
intercalate _ []     = mempty
intercalate z (x:xs) = Melody $ step xs (getMelody x)
  where
    z1              = getMelody z
    step []     ac  = ac
    step (m:ms) ac  = step ms (ac `appendH` z1 `appendH` (getMelody m)) 


permutations :: Melody pch -> [Melody pch]
permutations = 
    map (Melody . fromListH) . List.permutations . toListH . getMelody


data AorB = A | B deriving (Eq)


-- | How to handle rests?
--
-- Append rest to the last accumulator...
--
partition :: (pch -> Bool) -> Melody pch 
          -> (Melody pch, Melody pch)
partition f m = step (toListH $ getMelody m) A emptyH emptyH
  where
    step []         _ ac1 ac2 = (Melody ac1, Melody ac2)
    step (R : xs)   A ac1 ac2 = step xs A (ac1 `snocH` R) ac2
    step (R : xs)   B ac1 ac2 = step xs B ac1 (ac2 `snocH` R)
    step (N p : xs) _ ac1 ac2 = 
        if f p then step xs A (ac1 `snocH` (N p)) ac2
               else step xs B ac1 (ac2 `snocH` (N p))



duplicate :: Int -> Melody pch -> Melody pch
duplicate i m = Melody $ fn (toListH $ getMelody m) emptyH
  where
    fn (x:xs) ac = fn xs (ac `appendH` replicateH i x)
    fn []     ac = ac


--------------------------------------------------------------------------------
-- Musical operations 

-- Note - retrograde is just reverse on a string, retrograde
-- becomes a more interesting transformation when you have
-- rests. Retrograde can then respect the metrical 
-- pattern, reversing just the contour of the pitches. 



retrograde :: Melody obj -> Melody obj
retrograde = listfun $ \os -> retro (collectPs os) os
  where
    collectPs (N p:os)          = p : collectPs os
    collectPs (_:os)            = collectPs os
    collectPs []                = []
    
    retro (p:ps) (N _:os)       = N p : retro ps os
    retro ps     (o:os)         = o : retro ps os
    retro _      []             = []



{-






permute :: Melody pch -> Melody pch
permute = listfun (List.concat . List.permutations)

partition :: (pch -> Bool) -> Melody pch -> (Melody pch, Melody pch)
partition f ma = (filter f ma, filter (not . f) ma)



-- evens & odds - reduce a pattern
evens :: Melody pch -> Melody pch
evens = listfun fn
  where
    fn (_:b:xs) = b : fn xs
    fn _        = []

odds :: Melody pch -> Melody pch
odds = listfun fn
  where
    fn (a:_b:xs) = a : fn xs
    fn xs        = xs

oddeven :: Melody pch -> Melody pch
oddeven a = odds a <> evens a




doubled :: Melody pch -> Melody pch
doubled = listfun fn
  where
    fn (a:xs) = a : a : fn xs
    fn xs       = xs



-}

